(*
 * Pretty Print From Abstract Syntax 2 Concret Syntax
 *
 *
 *)




(* Sintassi astratta -> string pic *)

open Format;;


class picmodel p =

   object (s)
   inherit mk_state p


   method exp_to_str e =
        match e with 
          Const(Bool b) -> string_of_bool b
        | Const(Int i) -> string_of_int i
        | Const(Ch c) -> c
        | Var v -> v
        | Op(ob, e1, e2) -> ("("^(s#exp_to_str e1)^" "^ob^" "^(s#exp_to_str e2)^")")
        

   method explist_to_str le = 
        match le with
          [] -> ""
        | e::l ->  let virgola = if l==[] then "" else "," 
                   in (s#exp_to_str e)^virgola^(s#explist_to_str l) 

   method varlist_to_str lv = 
        match lv with
          [] -> ""
        | Var v::l -> let virgola = if l==[] then "" else "," 
                       in v^virgola^(s#varlist_to_str l) 
        | _ -> raise (SynErr "In varlist elemento non atteso")


   method ppsuffix ppf p =
           match p with
             Zero -> ()
           | _ -> (fprintf ppf "%s" ".";
                   s#ppas2cs ppf p)


   method ht2str ht =
            match ht with
              HTConst(c) -> 
                ( match c with 
                    Bool(b) -> string_of_bool b
                  | Int(n) -> string_of_int n
                  | Ch(c) -> c
                )
            | HTVar -> "##"
            | HTNB  -> raise NP
               
 
   method env2str ppf e =
            let rec vh2str v h = (v^":"^(s#ht2str h))
            
            and aux l acc =
                match l with
                    [] -> acc
                 | (v,h)::[] -> (acc^(vh2str v h))
                 | (v,h)::y  -> aux y (acc^(vh2str v h)^", ")

            in (fprintf ppf "@.%s@." ("<"^(aux (MyEnv.env2list e) "")^">"))

   method epq2str ppf q = 
           let printep item =
                   match !item with
                      (e,p) -> 
                         (s#env2str ppf e;
                          s#ppas2cs ppf p;)
           in MyQueue.qiter q printep

   method run2str ppf =
           s#epq2str ppf run
           
   method heap2str ppf = 
          let hl = MyHeap.heap2list heap
          in let rec aux hl =
                     match hl with
                       [] -> ()
                     |(v,q)::t  -> (fprintf ppf "--->%s" v;
                                    s#epq2str ppf q; fprintf ppf "\n" ; aux t)
              in aux hl 
                    

   method  print ppf =
           fprintf ppf "@.@.@.%s@." "--------------- HEAP ---------------";
           s#heap2str ppf;
           fprintf ppf "@.%s" "--------------- RUN ----------------";
           s#run2str ppf
           
   method ppnew p =
        let rec aux p acc =
           match p with
             New(v, p) -> aux p (acc^v^" ")
           | p ->  (acc,p)
        in aux p ""

   method ppas2cs ppf p=
        match p with
          Zero -> fprintf ppf "%s" "()"

        | New(_) -> 
              let (v,p) = s#ppnew p
              in (fprintf ppf "@[<v 2>%s %s %s@;@[" "new" v "in";
                  s#ppas2cs ppf p;
                  fprintf ppf "@]@]")
        | In(v, lv, p) ->
              fprintf ppf "%s%s%s%s" v "?[" (s#varlist_to_str lv) "]";  
              s#ppsuffix ppf p
        | Inrec(v, lv, p) ->
              fprintf ppf "%s%s%s%s"  v "?*[" (s#varlist_to_str lv) "]";
              s#ppsuffix ppf p
        | Out(v, le, p) ->
              fprintf ppf "%s%s%s%s" v "![" (s#explist_to_str le) "]";
              s#ppsuffix ppf p
        | Print(le, p) -> 
              fprintf ppf "%s%s%s" "print![" (s#explist_to_str le) "]"; 
              s#ppsuffix ppf p
        | Par(p1, p2) -> 
              fprintf ppf "%s" "(";
              s#ppas2cs ppf p1;
              fprintf ppf " %s@ " "|";
              s#ppas2cs ppf p2;
              fprintf ppf "%s" ")"
        | Cond(exp, t, e) ->
              fprintf ppf "@[<v 3>%s %s" "(if" (s#exp_to_str exp);
              fprintf ppf "@;%s@[" "then ";
              s#ppas2cs ppf t;
              fprintf ppf "@]@;%s@[" "else ";
              s#ppas2cs ppf e;
              fprintf ppf "%s@]@]" ")"
 
    method varch2ch env c =
            if MyEnv.isindom c env
                  then match MyEnv.valinenv c env with
                         HTNB -> c
                       | HTConst(Ch(c)) -> c
                       | _ -> raise NP
                  else c


    method pe2as env p =
       match p with
         Zero -> Zero
       | New(v,p) -> (* dichiariamo in env che v non e' bound *)
          let newenv = MyEnv.updateenv (v,HTNB) env   
           in New (v, (s#pe2as newenv p))
       | Par(p,q) -> Par(s#pe2as env p, s#pe2as env q)
       | Cond(exp, t, e) -> Cond(exp, s#pe2as env t, s#pe2as env e)
       | Print(le, p) -> Print(le, s#pe2as env p)
       | In(c,lv,_)|Inrec(c,lv,_) ->
             let namech = s#varch2ch env c
             in let rec aux lv env =
                  match lv with
                     [] -> env
                  |  (Var(x))::y -> let newenv =  MyEnv.updateenv (x,HTNB) env
                                  in aux y newenv
                  |  _ -> raise NP
              in let newenv = aux lv env 
                 in ( match p with 
                       In(_,_,p) -> In(namech, lv, s#pe2as newenv p)
                      | Inrec(_,_,p) -> Inrec(namech, lv, s#pe2as newenv p)
                      | _ -> raise NP
                    )
       | Out(c, le, p) ->
             let namech = s#varch2ch env c
             in Out(namech, le, s#pe2as env p)


    method epq2par q = (* coda (e,p) -> par *)
       let l = MyQueue.queue2list q
       in let rec aux l =
               match l with
                  [] -> Zero
               | x::[] ->
                   (match !x with
                     (e,p) -> s#pe2as e p
                   )
               | x::y -> 
                   (match !x with
                     (e,p) -> Par(s#pe2as e p, aux y)
                   )
          in aux l

    method heap2par = (* 1) heap2list (ch,q)
                         2) Par(epq2par q, ...) *)
          let l =  MyHeap.heap2list heap
          in let rec aux l =
                match l with
                   [] -> Zero
                | (c,q)::y -> Par(s#epq2par q, aux y)
             in  aux l

    method am2as =    (* 1) tutti i processi in run in parallelo
                         2) tutti i processi in heap in parallelo
                         3) parallelo di 1) e 2)
                         4) new per tutti i canali in heap; New(_, 3)
                       *)
        let parrun = s#epq2par run
        in let parheap = s#heap2par
           in let l = MyHeap.heap2list heap
              in let rec aux l =
                      match l with
                         [] -> Par(parrun, parheap)
                      | (x,_)::y -> New(x, aux y)
                  in aux l

    method am2cs ppf = s#ppas2cs ppf s#am2as

    method pprint ppf = s#am2cs ppf

    method pptest str =
        let sa = (new picparser(new picscanner(str)))#beginparse
        in s#ppas2cs std_formatter sa


    method pptestout = 
            let (e,p) = MyQueue.qhd run
            in (fprintf std_formatter "@.";
                s#ppas2cs std_formatter p; 
                fprintf std_formatter "@.")
end;;



(* graphics prova *)
#load "graphics.cma";;
open Graphics;;

class picviewgr (model : picmodel) =

   object (s)
   val model = model

   method wn () = 
       let rec aux () = 
               let s =(wait_next_event [Key_pressed])
               in ( draw_char s.key;
                    match s.key with
                      'n' -> sound 440 125; ()
                    | 'a'..'z' -> aux () 
                    | _ -> draw_string "by by"; aux ())
       in aux ()

   method init =
        open_graph "";
        set_window_title "MyPic";

   method getEvent = s#wn(); 
        
   method close = close_graph

   method out =  (model#pptestout)

 end;;

(* controller  *)

class piccontroller (model : picmodel) (view : picviewgr) =
        object (s)

        val model = model
        val view = view

        method init = view#init
          
        method out = view#out

        method close = view#close

        method start  = s#init; s#out; s#close

end;;


(* test parser *)




let pptest s=
        
        print_string ("\n"^s^"\n");
        let sa = (new picparser(new picscanner(s)))#beginparse
        in let m = (new picmodel(sa))
           in let v = (new picviewgr(m))
              in let c = (new piccontroller m v)
                 in c#out ;;

let s1 = "(new c in c?[] | c?[])";;
let s2 = "a?[] | b?[] | new c in c?[]";;
let s3 = "a?[] | new c in c?[]";;
let s4 = "(a?[] | b?[] | c?[])" ;;
let s5 = "if false then a?[] | b?[] | c?[] else ()";;
let s6 = "(if (true) then (a?[] | b?[] | c?[]) else (()) )";;
let s7 = "def Fact[n,r] = (if n=0 then r![1] else new p in Fact![n-1,p]|p?[x].r![n * x]) in new q in (Fact![3,q] | q?[v].print![v])";;
let s8 = "new a in new b in new c in (a?[a].a?[a].print![a] | a![b] | b![false])" ;;
let s9 = "def Inc[n,r] = (r![n+1]) in new q in (Inc![0,q]|q?[x].print![x])";;
let s10 = "new inc in (inc?[x,r].r![x+1] | new q in (inc![0,q].q?[x].print![x]))" ;;
let s11 = "new inc in (inc?*[x,r].r![x+1] | new q in (inc![0,q].q?[x].print![x]))" ;;
let s12 = "def Fact[n,r]=(if n=0 then r![1] else (new q in (Fact![n-1,q]|q?[x].r![n*x]))) in (new p in (Fact![3,p]|p?[x].print![x]))";;
let s13 =  "def True[r]=(new b in r![b] | b?*[t,f].t![]) and False[r] = (new b in r![b] | b?*[t,f].f![]) in ()" ;;
pptest s1;;
pptest s2;;
pptest s3;;
pptest s4;;
pptest s5;;
pptest s6;;
pptest s7;;
pptest s8;;
pptest s9;;

let pp s = new picmodel ((new picparser(new picscanner s))#beginparse);;
let mp = pp s12;;

let rec pnextn mp n =
        if n>0 
           then
             (mp#print std_formatter ;
              mp#next; 
              pnextn mp (n-1) )
           else 
              () ;;

let rec ppnextn mp n =
        if n>0 
           then
             (mp#pprint std_formatter ;
              mp#next; 
              print_string "\n ---> \n";
              ppnextn mp (n-1) )
           else 
              () ;;





